home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Pascal / Source□ / Talk Source / My Libraries / MyFMenus.unit < prev    next >
Encoding:
Text File  |  1992-04-20  |  5.5 KB  |  268 lines  |  [TEXT/PJMM]
  1. unit MyFMenus;
  2.  
  3. { This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
  4.  
  5. interface
  6.  
  7.     procedure InitFMenus (default: procptr);
  8. { procedure default(themenu,theitem:integer) }
  9.     procedure FinishFMenus;
  10.     function GetFMenu (id: integer): MenuHandle;
  11.     procedure AddFCommand (themenu, theitem: integer; command: OSType);
  12.     procedure SetFCommand (command: OSType; cmdproc: procptr);
  13. { procedure cmdproc }
  14.     procedure SetFSetMenu (command: OSType; smproc: procptr);
  15. { procedure smproc(themenu,theitem:integer) }
  16.     procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
  17.     procedure GetCommand (themenu, theitem: integer; var command: OSType);
  18.     procedure DoCommand (themenu, theitem: integer; command: OSType);
  19.     procedure DoFMenu (themenu, theitem: integer);
  20.     procedure SetFMenus;
  21.  
  22. implementation
  23.  
  24.     uses
  25.         BaseGlobals;
  26.  
  27.     procedure DoSMP (themenu, theitem: integer; smp: procptr);
  28.     inline
  29.         $205F, $4E90;
  30.  
  31.     procedure DoDefCMDP (themenu, theitem: integer; cmdp: procptr);
  32.     inline
  33.         $205F, $4E90;
  34.  
  35.     procedure DoCMDP (cmdp: procptr);
  36.     inline
  37.         $205F, $4E90;
  38.  
  39.     type
  40.         fmenuHeader = record
  41.                 visible: integer;
  42.                 count: integer;
  43.                 unknown1: integer;
  44.                 menuID: integer;
  45.                 unknown2: integer;
  46.                 unknown3: integer;
  47.                 name: str63;
  48.             end;
  49.         fmenuHeaderPtr = ^fmenuHeader;
  50.         fmenuItem = packed record
  51.                 command: OSType;
  52.                 mark: char;
  53.                 unknown2: byte;
  54.                 cmdKey: char;
  55.                 disabled: byte;
  56.                 name: str63;
  57.             end;
  58.         fmenuItemPtr = ^fmenuItem;
  59.         convertRecord = record
  60.                 menu, item: integer;
  61.                 cmd: OSType;
  62.                 cmdp, smp: procptr;
  63.             end;
  64.         convertArray = array[1..1000] of convertRecord;
  65.         convertPtr = ^convertArray;
  66.         convertHandle = ^convertPtr;
  67.  
  68.     var
  69.         defaultproc: procptr;
  70.         convert_count: integer;
  71.         converts: convertHandle;
  72.  
  73. {$S Init}
  74.     procedure InitFMenus (default: procptr);
  75. { procedure default(themenu,theitem:integer) }
  76.     begin
  77.         defaultproc := default;
  78.         convert_count := 0;
  79.         converts := convertHandle(NewHandle(0));
  80.     end;
  81.  
  82. {$S Term}
  83.     procedure FinishFMenus;
  84.     begin
  85.         DisposHandle(handle(converts));
  86.     end;
  87.  
  88. {$S Init}
  89.     procedure AddFCommand (themenu, theitem: integer; command: OSType);
  90.     begin
  91.         if BAND(convert_count, 7) = 0 then
  92.             SetHandleSize(handle(converts), (convert_count + 8) * SizeOf(convertRecord));
  93.         convert_count := convert_count + 1;
  94.         with converts^^[convert_count] do begin
  95.             menu := themenu;
  96.             item := theitem;
  97.             cmd := command;
  98.             cmdp := defaultproc;
  99.             smp := nil;
  100.         end;
  101.     end;
  102.  
  103. {$S Init}
  104.     procedure NextPtr (var p: univ ptr; sp: univ ptr);
  105.     begin
  106.         p := ptr(longInt(sp) + sp^ + 2 - ord(odd(sp^)));
  107.     end;
  108.  
  109. {$S Init}
  110.     function GetFMenu (id: integer): MenuHandle;
  111.         var
  112.             h: handle;
  113.             mh: menuHandle;
  114.             ph: fmenuHeaderPtr;
  115.             p: fmenuItemPtr;
  116.             s: string[70];
  117.             i: integer;
  118.     begin
  119.         h := GetResource('fmnu', id);
  120.         HLock(h);
  121.         ph := fmenuHeaderPtr(h^);
  122.         mh := NewMenu(ph^.menuID, ph^.name);
  123.         NextPtr(p, @ph^.name);
  124.         for i := 1 to ph^.count do begin
  125.             if p^.name = '-' then
  126.                 AppendMenu(mh, '(-')
  127.             else begin
  128.                 AddFCommand(ph^.menuID, i, p^.command);
  129.                 s := p^.name;
  130.                 if p^.mark <> chr(0) then
  131.                     s := concat(s, '!', p^.mark);
  132.                 if p^.cmdKey <> chr(0) then
  133.                     s := concat(s, '/', p^.cmdKey);
  134.                 if p^.disabled = 1 then
  135.                     s := concat('(', s);
  136.                 AppendMenu(mh, s);
  137.             end;
  138.             NextPtr(p, @p^.name);
  139.         end;
  140.         DisposHandle(h);
  141.         GetFMenu := mh;
  142.     end;
  143.  
  144. {$S}
  145.     procedure FindCommand (command: OSType; var cmdproc: procptr);
  146.         var
  147.             i: integer;
  148.     begin
  149.         i := 1;
  150.         while i <= convert_count do begin
  151.             with converts^^[i] do
  152.                 if cmd = command then begin
  153.                     cmdproc := cmdp;
  154.                     Exit(FindCommand);
  155.                 end;
  156.             i := i + 1;
  157.         end;
  158.         cmdproc := defaultproc;
  159.     end;
  160.  
  161. {$S}
  162.     procedure FindMenu (themenu, theitem: integer; var i: integer);
  163.     begin
  164.         i := 1;
  165.         while i <= convert_count do begin
  166.             with converts^^[i] do
  167.                 if (menu = themenu) and (item = theitem) then
  168.                     Exit(FindMenu);
  169.             i := i + 1;
  170.         end;
  171.         i := -1;
  172.     end;
  173.  
  174. {$S Init}
  175.     procedure SetFCommand (command: OSType; cmdproc: procptr);
  176. { procedure cmdproc }
  177.         var
  178.             i: integer;
  179.     begin
  180.         for i := 1 to convert_count do
  181.             with converts^^[i] do
  182.                 if cmd = command then
  183.                     cmdp := cmdproc;
  184.     end;
  185.  
  186. {$S Init}
  187.     procedure SetFSetMenu (command: OSType; smproc: procptr);
  188. { procedure smproc }
  189.         var
  190.             i: integer;
  191.     begin
  192.         for i := 1 to convert_count do
  193.             with converts^^[i] do
  194.                 if cmd = command then
  195.                     smp := smproc;
  196.     end;
  197.  
  198. {$S Init}
  199.     procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
  200. { procedure smproc }
  201.         var
  202.             i: integer;
  203.     begin
  204.         for i := 1 to convert_count do
  205.             with converts^^[i] do
  206.                 if cmd = command then begin
  207.                     cmdp := cmdproc;
  208.                     smp := smproc;
  209.                 end;
  210.     end;
  211.  
  212. {$S}
  213.     procedure GetCommand (themenu, theitem: integer; var command: OSType);
  214.         var
  215.             i: integer;
  216.     begin
  217.         FindMenu(themenu, theitem, i);
  218.         if i = -1 then
  219.             command := 'xxx0'
  220.         else
  221.             command := converts^^[i].cmd;
  222.     end;
  223.  
  224. {$S}
  225.     procedure DoCmd (themenu, theitem: integer; cmdp: procptr);
  226.     begin
  227.         if cmdp = defaultproc then
  228.             DoDefCMDP(themenu, theitem, cmdp)
  229.         else
  230.             DoCMDP(cmdp);
  231.     end;
  232.  
  233. {$S}
  234.     procedure DoCommand (themenu, theitem: integer; command: OSType);
  235.         var
  236.             cmdproc: procptr;
  237.     begin
  238.         FindCommand(command, cmdproc);
  239.         DoCmd(themenu, theitem, cmdproc);
  240.     end;
  241.  
  242. {$S}
  243.     procedure DoFMenu (themenu, theitem: integer);
  244.         var
  245.             i: integer;
  246.     begin
  247.         FindMenu(themenu, theitem, i);
  248.         if i = -1 then
  249.             DoCmd(themenu, theitem, defaultproc)
  250.         else
  251.             with converts^^[i] do
  252.                 DoCmd(themenu, theitem, cmdp);
  253.         if not quitNow then
  254.             HiliteMenu(0);
  255.     end;
  256.  
  257. {$S}
  258.     procedure SetFMenus;
  259.         var
  260.             i: integer;
  261.     begin
  262.         for i := 1 to convert_count do
  263.             with converts^^[i] do
  264.                 if smp <> nil then
  265.                     DoSMP(menu, item, smp);
  266.     end;
  267.  
  268. end.